(* Lazyfication of OCaml programs *)

open Parsetree;;
open Longident;;
open Asttypes

(* Longident *)

let lazy_id id = "Lazy_" ^ (String.uncapitalize id)

let rec lazy_longident lid = match lid with
  | Lident id -> Lident (lazy_id id)
  | Ldot (lid, id) -> Ldot (lazy_longident lid, lazy_id id)
  | Lapply (lid1, lid2) -> Lapply (lazy_longident lid1, lazy_longident lid2)

let rec longident lid =
  match lid with
    | Lident _ -> lid
    | Ldot (lid, id) -> Ldot (lazy_longident lid, id)
    | Lapply (lid1, lid2) -> Lapply (longident lid1, longident lid2)

(* Type expressions for the core language *)

let rec core_type ct = {
  ptyp_desc = core_type_desc ct.ptyp_desc;
  ptyp_loc = ct.ptyp_loc;
}

and lazy_core_type_desc ctd loc =
  Ptyp_constr (Lident "lazy_t", [{ ptyp_desc = ctd; ptyp_loc = loc}])

and lazy_core_type ct = {
  ptyp_desc = lazy_core_type_desc (core_type_desc ct.ptyp_desc) ct.ptyp_loc;
  ptyp_loc = ct.ptyp_loc;
}

and core_type_desc ctd = 
  match ctd with
    | Ptyp_any | Ptyp_var _ ->
	ctd

    | Ptyp_arrow (lab, ct1, ct2) ->
	Ptyp_arrow (lab, lazy_core_type ct1, core_type ct2) (*lazy.t t1 -> t2*)

    | Ptyp_tuple ct_list ->
	Ptyp_tuple (List.map lazy_core_type ct_list)

    | Ptyp_constr (Ldot (Lident "*predef*", "option"), [ ct ]) ->
	core_type_desc ct.ptyp_desc

    | Ptyp_constr (longid, ct_list) ->
	Ptyp_constr (longident longid, List.map core_type ct_list)

    | Ptyp_object core_field_type_list -> 
	Ptyp_object (List.map core_field_type core_field_type_list)

    | Ptyp_class (longid, ct_list, label_list) ->
	Ptyp_class (longident longid, List.map core_type ct_list, label_list)

    | Ptyp_alias (ct, str) ->
	Ptyp_alias (core_type ct, str)

    | Ptyp_variant (row_field_list, bool, olabel_list) ->
	Ptyp_variant(List.map row_field row_field_list, bool, olabel_list)

    | Ptyp_poly (str_list, ct) ->
	Ptyp_poly (str_list, core_type ct)

    | Ptyp_package pt ->
	Ptyp_package (package_type pt)

and nonlazy_core_type ct = {
  ptyp_desc = nonlazy_core_type_desc ct.ptyp_desc;
  ptyp_loc = ct.ptyp_loc;
}

and nonlazy_core_type_desc ctd = 
  match ctd with
    | Ptyp_any ->
	Ptyp_any (* _ *)

    | Ptyp_var(str) ->
	Ptyp_var (str) (* 'a, 'b, etc. *)

    | Ptyp_arrow (lab, ct1, ct2) ->
	Ptyp_arrow (lab, nonlazy_core_type ct1, nonlazy_core_type ct2)

    | Ptyp_tuple ct_list ->
	Ptyp_tuple (List.map nonlazy_core_type ct_list)
	  
    | Ptyp_constr (Ldot (Lident "*predef*", "option"), [ ct ]) ->
	nonlazy_core_type_desc ct.ptyp_desc

    | Ptyp_constr (longid, ct_list) ->
	Ptyp_constr (longident longid, List.map nonlazy_core_type ct_list)

    | Ptyp_object core_field_type_list -> 
	Ptyp_object (List.map nonlazy_core_field_type core_field_type_list)

    | Ptyp_class (longid, ct_list, label_list) ->
	Ptyp_class (longident longid, List.map nonlazy_core_type ct_list,
		    label_list)

    | Ptyp_alias (ct, str) ->
	Ptyp_alias (nonlazy_core_type ct, str)

    | Ptyp_variant(row_field_list, bool, olabel_list) ->
	Ptyp_variant(List.map nonlazy_row_field row_field_list, bool,
		     olabel_list)

    | Ptyp_poly (str_list, ct) ->
	Ptyp_poly(str_list, nonlazy_core_type ct)

    | Ptyp_package pt ->
	Ptyp_package (package_type pt)

and package_type (longid, string_core_type_list) =
  (longident longid, string_core_type_list)

and core_field_type cft = {
  pfield_desc = core_field_desc cft.pfield_desc;
  pfield_loc = cft.pfield_loc;
}

and core_field_desc cfd = match cfd with
  | Pfield (str, ct) -> Pfield (str, core_type ct)
  | Pfield_var -> Pfield_var

and nonlazy_core_field_type cft = {
  pfield_desc = nonlazy_core_field_desc cft.pfield_desc;
  pfield_loc = cft.pfield_loc;
}

and nonlazy_core_field_desc cfd = match cfd with
  | Pfield (str, ct) -> Pfield (str, nonlazy_core_type ct)
  | Pfield_var -> Pfield_var

and row_field rf = match rf with
  | Rtag (lab, bool, cts) -> Rtag (lab, bool, List.map lazy_core_type cts)
  | Rinherit (ct) -> Rinherit (core_type ct)

and nonlazy_row_field rf = match rf with
  | Rtag (lab, bool, cts) ->
      Rtag (lab, bool, List.map nonlazy_core_type cts)
  | Rinherit (ct) ->
      Rinherit (nonlazy_core_type ct)
;;

(* Type expressions for the class language *)

let class_infos f classinfo = 
  { classinfo with pci_expr = f classinfo.pci_expr }

(* Value expressions for the core language *)

let rec lazy_pattern p = {
  ppat_desc = lazy_pattern_desc p.ppat_desc p.ppat_loc;
  ppat_loc = p.ppat_loc;
}

and lazy_pattern_desc pdesc loc =
  let mklazy desc = Ppat_lazy { ppat_desc = desc; ppat_loc = loc } in
  let option opat = match opat with
    | None -> None
    | Some p -> Some (lazy_pattern p)
  in
  match pdesc  with
    | Ppat_any | Ppat_var _ | Ppat_type _ ->
	pdesc

    | Ppat_constant _ ->
	mklazy pdesc

    | Ppat_alias (p, s) ->
	Ppat_alias (lazy_pattern p, s)

    | Ppat_tuple pat_list ->
        mklazy (Ppat_tuple (List.map lazy_pattern pat_list))

    | Ppat_construct (Lident "[]", opat, b) ->
        mklazy (Ppat_construct (Lident "LNil_", opat, b))

    | Ppat_construct (Lident "::",
		      Some { ppat_desc = Ppat_tuple [ p1 ; p2 ] ;
			     ppat_loc = loc }, false) ->
        mklazy (
          Ppat_construct (
            Lident "LCons_",
	    Some { ppat_desc = Ppat_tuple [ lazy_pattern p1 ; lazy_pattern p2 ];
			     ppat_loc = loc }, false)
        )

    | Ppat_construct (Lident "::",_ , _) ->
	assert false

    | Ppat_construct (longid, opat, b) ->
        mklazy (Ppat_construct (longident longid, option opat, b))

    | Ppat_variant (label, opat) ->
        mklazy (Ppat_variant (label, option opat))

    | Ppat_record (longid_pattern_list, closed_flag) ->
        mklazy (Ppat_record (List.map (fun (lid, pat) ->
					 (longident lid, lazy_pattern pat))
                               longid_pattern_list, closed_flag))

    | Ppat_array patlist ->
        mklazy (Ppat_array (List.map lazy_pattern patlist))

    | Ppat_or (p1, p2) ->
	Ppat_or (lazy_pattern p1, lazy_pattern p2)

    | Ppat_constraint (pat, ct) ->
        Ppat_constraint (lazy_pattern pat, lazy_core_type ct)

    | Ppat_lazy p ->
	mklazy (Ppat_lazy (lazy_pattern p))

and pattern p = {
  ppat_desc = pattern_desc p.ppat_desc;
  ppat_loc = p.ppat_loc;
}

and pattern_desc pdesc =
  let option opat = match opat with
    | None -> None
    | Some p -> Some (lazy_pattern p)
 in
  match pdesc  with
    | Ppat_any | Ppat_var _ | Ppat_type _ | Ppat_constant _ ->
	pdesc

    | Ppat_alias (p, s) ->
	Ppat_alias (pattern p, s)

    | Ppat_tuple pat_list ->
        Ppat_tuple (List.map lazy_pattern pat_list)

    | Ppat_construct (Lident "[]", opat, b) ->
        Ppat_construct (Lident "LNil_", opat, b)

    | Ppat_construct (Lident "::",
		      Some { ppat_desc = Ppat_tuple [ p1 ; p2 ] ;
			     ppat_loc = loc }, false) ->
        Ppat_construct (
          Lident "LCons_",
	  Some { ppat_desc = Ppat_tuple [ lazy_pattern p1 ; lazy_pattern p2 ];
		 ppat_loc = loc }, false)

    | Ppat_construct (Lident "::",_ , _) ->
	assert false

    | Ppat_construct (longid, opat, b) ->
        Ppat_construct (longident longid, option opat, b)

    | Ppat_variant (label, opat) ->
        Ppat_variant (label, option opat)

    | Ppat_record (longid_pattern_list, closed_flag) ->
        Ppat_record (List.map (fun (lid, pat) ->
				 (longident lid, lazy_pattern pat))
                       longid_pattern_list, closed_flag)

    | Ppat_array patlist ->
        Ppat_array (List.map lazy_pattern patlist)

    | Ppat_or (p1, p2) ->
	Ppat_or (pattern p1, pattern p2)
	  
    | Ppat_constraint (pat, ct) ->
        Ppat_constraint (pattern pat, core_type ct)

    | Ppat_lazy p ->
	Ppat_lazy (lazy_pattern p)

let rec expression e = {
  pexp_desc = expression_desc e.pexp_desc;
  pexp_loc = e.pexp_loc;
}

and delay_expr e =
  let e' = expression_desc e.pexp_desc in
    match e' with
      | Pexp_apply ({ pexp_desc =
			Pexp_ident (Ldot (Lident "CamlinternalLazy", "force"));
		      pexp_loc = _}, [
		      ("", ({ pexp_desc = Pexp_ident _; pexp_loc = _ }
			      as sub_expr)) ]) ->
	  sub_expr
      | _ -> {
	  pexp_desc =
	    Pexp_lazy {
	      pexp_desc = e';
	      pexp_loc = e.pexp_loc;
	    };
	  pexp_loc = e.pexp_loc;
	}
	  
and force_edesc ed loc =
  Pexp_apply(
    { pexp_desc = Pexp_ident(Ldot(Lident "CamlinternalLazy", "force"));
      pexp_loc = loc },
    [ ("", { pexp_desc = ed;
             pexp_loc = loc }) ]
  )

(* Type expressions for the module language *)

and module_type mt = {
  pmty_desc = module_type_desc mt.pmty_desc;
  pmty_loc = mt.pmty_loc;
}

and module_type_desc mtd =
 match mtd with
   | Pmty_ident (longid) ->
       Pmty_ident (lazy_longident longid)
   | Pmty_signature (siga) ->
       Pmty_signature (signature siga)
   | Pmty_functor (str, mt1, mt2) ->
       Pmty_functor (lazy_id str, module_type mt1, module_type mt2)
   | Pmty_with (mt, longid_withconstraint_list) ->
       Pmty_with (module_type mt,
		  List.map (fun (lid, wc) ->
			      (longident lid, with_constraint wc))
		    longid_withconstraint_list)
   | Pmty_typeof (mexpr) ->
       Pmty_typeof (module_expr mexpr)

and module_expr me = {
  pmod_desc = module_expr_desc me.pmod_desc;
  pmod_loc = me.pmod_loc
}

and module_expr_desc med = 
  match med with
    | Pmod_ident (longid) ->
	Pmod_ident (lazy_longident longid)

    | Pmod_structure (struc) ->
	Pmod_structure (structure struc)

    | Pmod_functor (str, mt, me) ->
	Pmod_functor (lazy_id str, module_type mt, module_expr me)

    | Pmod_apply (mexpr1, mexpr2) ->
	Pmod_apply (module_expr mexpr1, module_expr mexpr2)

    | Pmod_constraint (mexpr, mty) ->
	Pmod_constraint (module_expr mexpr, module_type mty)

    | Pmod_unpack (expr, pacty) ->
	Pmod_unpack (expression expr, package_type pacty)

and expression_desc e =
  let option eopt = match eopt with
    | None -> None
    | Some e -> Some (expression e)
  and delay_option eopt = match eopt with
    | None -> None
    | Some e -> Some (delay_expr e)
  and option_t oct = match oct with
    | None -> None
    | Some p -> Some (core_type p)
  and delay_option_t oct = match oct with
    | None -> None
    | Some p -> Some (lazy_core_type p)
  in
  match e with
    | Pexp_ident longid ->
	force_edesc (Pexp_ident (longident longid)) Location.none

    | Pexp_constant _ ->
	e

    | Pexp_let (rf, pat_expr_list, e2) ->
	Pexp_let (rf, List.map (fun (p1, e1) ->
				  (lazy_pattern p1, delay_expr e1))
                    pat_expr_list, expression e2)

    | Pexp_function (lab, oexpr, pat_expr_list) ->
	Pexp_function (lab, delay_option oexpr,
                       List.map
			 (fun (p, e) -> (lazy_pattern p, expression e))
			 pat_expr_list)

    | Pexp_apply (ef, label_expression_list) ->
	Pexp_apply (expression ef,
                    List.map (fun (lab, expr) -> (lab, delay_expr expr))
                      label_expression_list)

    | Pexp_match (em, pattern_expression_list) ->
	Pexp_match (delay_expr em,
	            List.map (fun (p, e) -> (lazy_pattern p, expression e))
		      pattern_expression_list)

    | Pexp_try (et, pattern_expression_list) ->
	let exp exp_desc = { pexp_desc = exp_desc; pexp_loc = Location.none } in
	let pat pat_desc = { ppat_desc = pat_desc; ppat_loc = Location.none } in
	let var = "camlinternal_exn_" in
	let import = "camlinternal_import_exn_" in
	let raise = Ldot (Lident "Pervasives", "raise") in
	let pe_list =
	  let l =
	    List.map (fun (p, e) -> (lazy_pattern p, expression e))
	      pattern_expression_list
	  in
	  let rec is_any ({ ppat_desc = pat ; ppat_loc = _ }, e) =
	    match pat with
	      | Ppat_any | Ppat_var _ -> true
	      | Ppat_alias (p, _) -> is_any (p, e)
	      | _ -> false
	  in
	    if List.exists is_any pattern_expression_list then l
	    else
	      let arg = [ ("", exp (Pexp_ident (Lident var))) ] in
	      let call = Pexp_apply (exp (Pexp_ident raise), arg) in
		l @ [ (pat (Ppat_lazy (pat Ppat_any)), exp call) ]
	and call =
	  Pexp_lazy (exp (Pexp_apply ((exp (Pexp_ident (Lident import))),
				      [ ("", exp (Pexp_ident (Lident var))) ])))
	in
	let match_exp = Pexp_match (exp call, pe_list) in
	  Pexp_try (expression et, [ (pat (Ppat_var var), exp match_exp) ])

    | Pexp_tuple expression_list ->
	Pexp_tuple ( List.map delay_expr expression_list)

    | Pexp_construct (Lident "[]", oexp, bool) ->
        Pexp_construct (Lident "LNil_", oexp, bool)

    | Pexp_construct (Lident "::",
		      Some { pexp_desc = Pexp_tuple [ e1 ; e2 ] ;
			     pexp_loc = loc }, false) ->
        Pexp_construct (
          Lident "LCons_",
	  Some { pexp_desc = Pexp_tuple [ delay_expr e1 ; delay_expr e2 ] ;
                 pexp_loc = loc }, false)

    | Pexp_construct (Lident "::",_ , _) ->
	assert false

    | Pexp_construct (longid, oexp, bool) ->
	Pexp_construct (longident longid, delay_option oexp, bool)

    | Pexp_variant (label, oexp) ->
	Pexp_variant (label, delay_option oexp)

    | Pexp_record (longid_exp_list, oexp) ->
	Pexp_record (List.map (fun(longid, exp) ->
				 (longident longid, delay_expr exp))
	               longid_exp_list, option oexp)
        
    | Pexp_field (exp, longid) ->
	force_edesc (Pexp_field (expression exp, longident longid))
	  Location.none

    | Pexp_setfield (exp, longid, exp2) ->
	Pexp_setfield(expression exp, longident longid, delay_expr exp2)

    | Pexp_array (expression_list) ->
	Pexp_array (List.map delay_expr expression_list)

    | Pexp_ifthenelse (exp1, exp2, oexp) ->
	Pexp_ifthenelse(expression exp1, expression exp2, option oexp)

    | Pexp_sequence (exp1, exp2) ->
	Pexp_sequence (expression exp1, expression exp2)

    | Pexp_while (exp1, exp2) ->
	Pexp_while (expression exp1, expression exp2)

    | Pexp_for (str, exp1, exp2, direction_flag,  exp3) ->
	let pat_any = { ppat_desc = Ppat_any ; ppat_loc = Location.none }
        and pat_str = { ppat_desc = Ppat_var str; ppat_loc = Location.none }
	and exp_str = {
	  pexp_desc = Pexp_ident (Lident str);
	  pexp_loc = Location.none;
	} and delay_str = {
            pexp_desc = Pexp_lazy {
	    pexp_desc = Pexp_ident (Lident str);
	    pexp_loc = Location.none;
	  };
          pexp_loc = Location.none;
        }
        in
	let sublet = { (* to avoid warning (unused variable) *)
	  pexp_desc = Pexp_let (Nonrecursive, [ (pat_any, exp_str) ],
				expression exp3);
	  pexp_loc = Location.none;
	} in
        let body = {
	  pexp_desc = Pexp_let (Nonrecursive,
				[ (pat_str, delay_str) ],
				sublet);
          pexp_loc = exp3.pexp_loc
	} in
          Pexp_for (str, expression exp1, expression exp2, direction_flag, body)
	    
    | Pexp_constraint (exp, oct1, oct2) ->
	Pexp_constraint (expression exp, option_t oct1, option_t oct2)

    | Pexp_when (exp1, exp2) ->
	Pexp_when (expression exp1, expression exp2)

    | Pexp_send (exp, str) ->
	Pexp_send (expression exp, str)

    | Pexp_new longid ->
	Pexp_new (longident longid)

    | Pexp_setinstvar (str, exp) ->
	Pexp_setinstvar (str, expression exp)

    | Pexp_override (str_exp_list) ->
	Pexp_override (List.map (fun(str,exp) -> (str, expression exp))
			 str_exp_list)

    | Pexp_letmodule (str, mexpr, exp) ->
	Pexp_letmodule (lazy_id str, module_expr mexpr, expression exp)

    | Pexp_assert e ->
	Pexp_assert (expression e)

    | Pexp_assertfalse -> 
	Pexp_assertfalse

    | Pexp_lazy e ->
	Pexp_lazy (expression e)

    | Pexp_poly (exp, octy) ->
	Pexp_poly (expression exp, delay_option_t octy)

    | Pexp_object cs ->
	Pexp_object (class_structure cs)

    | Pexp_newtype (str, exp) ->
	Pexp_newtype (str, expression exp)

    | Pexp_pack (mexpr, pactyp) ->
	Pexp_pack (module_expr mexpr, package_type pactyp)

    | Pexp_open (longid, exp) ->
	Pexp_open (lazy_longident longid, expression exp)


(* Type declarations *)

and type_declaration td =
  { td with
    ptype_manifest =
      begin match td.ptype_manifest with
	| None -> None
	| Some ct -> Some (core_type ct)
      end;
    ptype_cstrs =
      List.map 
	(fun (ct1, ct2, loc) ->
	   (core_type ct1, core_type ct2, loc)) td.ptype_cstrs;
      ptype_kind = type_kind td.ptype_kind;
  }


and type_kind tk =
match tk with
  | Ptype_abstract ->
      Ptype_abstract

  | Ptype_variant (str_listOfCt_loc_list) ->
      Ptype_variant (
        List.map 
	  (fun (str, ct_list, loc) ->
	     match ct_list with
	       | [] -> (str, [], loc)
	       | [x] -> (str, [lazy_core_type x], loc)
	       | _ ->
		   (str, [ lazy_core_type { ptyp_desc = (Ptyp_tuple ct_list);
					    ptyp_loc = Location.none } ], loc))
	  str_listOfCt_loc_list)

  | Ptype_record str_mf_ct_loc_list ->
      Ptype_record (List.map 
		      (fun (str, mf, ct, loc) ->
			 (str, mf, lazy_core_type ct, loc))
                     str_mf_ct_loc_list)

and exception_declaration = List.map lazy_core_type

(* Type expressions for the class language *)

and class_type classty = {
  pcty_desc = class_type_desc classty.pcty_desc;
  pcty_loc = classty.pcty_loc;
}

and class_type_desc classtyd = match classtyd with
  | Pcty_constr (longid, ct_list) ->
      Pcty_constr (longident longid, (List.map core_type ct_list))
  | Pcty_signature classsig ->
      Pcty_signature (class_signature classsig)
  | Pcty_fun (lab, ct, classty) ->
      Pcty_fun (lab, core_type ct, class_type classty)

and class_signature (ct, class_type_field_list) =
  (core_type ct, List.map class_type_field class_type_field_list)

and class_type_field classtyf = match classtyf with
  | Pctf_inher (classty) -> Pctf_inher (class_type classty)
  | Pctf_val (str, mf, vf, ct, loc) -> Pctf_val (str, mf, vf, core_type ct, loc)
  | Pctf_virt (str, pf, ct, loc) -> Pctf_virt (str, pf, core_type ct, loc)
  | Pctf_meth (str, pf, ct, loc) -> Pctf_meth (str, pf, core_type ct, loc)
  | Pctf_cstr (ct1, ct2, loc) -> Pctf_cstr (core_type ct1, core_type ct2, loc)

and class_description cd  = class_infos class_type cd  

and class_type_declaration cd  = class_infos class_type cd  

(* Value expressions for the class language *)

and class_expr classex = {
  pcl_desc = class_expr_desc classex.pcl_desc;
  pcl_loc = classex.pcl_loc;
}

and class_expr_desc classexd =
  let option exp = match exp with
    | None -> None
    | Some exp -> Some (expression exp)
  in
  match classexd with
    | Pcl_constr (longid, ct_list) ->
        Pcl_constr (longident longid, List.map core_type ct_list)
    | Pcl_structure (classstr) ->
	Pcl_structure (class_structure classstr)
    | Pcl_fun (lab, oexp, pat, classex) ->
	Pcl_fun (lab, option oexp, lazy_pattern pat, class_expr classex)
    | Pcl_apply (classex, lab_exp_list) ->
	Pcl_apply (class_expr classex,
		   (List.map (fun (lab, exp) -> (lab, expression exp))
		      lab_exp_list))
    | Pcl_let (rec_flag, pat_exp_list, classex) ->
	Pcl_let (rec_flag, (List.map (fun (pat, exp) ->
					(lazy_pattern pat, expression exp))
			      pat_exp_list), class_expr classex)
    | Pcl_constraint (classex, classty) ->
	Pcl_constraint (class_expr classex, class_type classty)


and class_structure (pat, classfield_list) =
  (lazy_pattern pat, List.map class_field classfield_list)

and class_field classfi =
  let option_s str = match str with
    | None -> None
    | Some s -> Some s
  in
  match classfi with
    | Pcf_inher (oflag, classex, ostring ) ->
	Pcf_inher(oflag, class_expr classex, option_s ostring)

    | Pcf_valvirt (str, mf, ct, loc) ->
	Pcf_valvirt (str, mf, core_type ct, loc)

    | Pcf_val (str, mf, oflag, exp, loc) ->
	Pcf_val(str, mf, oflag, expression exp, loc)

    | Pcf_virt (str, pf, ct, loc) ->
	Pcf_virt (str, pf, core_type ct, loc)

    | Pcf_meth (str, pf, oflag, exp, loc) ->
	Pcf_meth (str, pf, oflag, expression exp, loc)

    | Pcf_cstr (ct1, ct2, loc) ->
	Pcf_cstr (core_type ct1, core_type ct2, loc)

    | Pcf_let (rec_flag, pat_exp_list, loc) ->
	Pcf_let (rec_flag, (List.map (fun (pat, exp) ->
					(lazy_pattern pat, expression exp))
			      pat_exp_list), loc)

    | Pcf_init (exp) ->
	Pcf_init (expression exp)


and class_declaration cd = class_infos class_expr cd

and signature s = List.map signature_item s

and signature_item sig_it = {
  psig_desc = signature_item_desc sig_it.psig_desc;
  psig_loc = sig_it.psig_loc;
}

and signature_item_desc sig_it_desc = match sig_it_desc with
  | Psig_value (name, val_desc) ->
      Psig_value (name, { pval_type = lazy_core_type val_desc.pval_type;
			  pval_prim = [] })

  | Psig_type name_type_decl_list ->
      Psig_type(List.map (fun (name, td) -> (name, type_declaration td))
                  name_type_decl_list)

  | Psig_exception (str, ecp_decl) ->
      Psig_exception (str, exception_declaration ecp_decl)

  | Psig_module (str, modty) ->
      Psig_module (lazy_id str, module_type modty)

  | Psig_recmodule str_modty_list ->
      Psig_recmodule (List.map (fun (str, modty) ->
				  (lazy_id str, module_type modty))
			str_modty_list)

  | Psig_modtype (str, modty_decl) ->
      Psig_modtype (lazy_id str, modtype_declaration modty_decl)

  | Psig_open longid ->
      Psig_open (lazy_longident longid)

  | Psig_include modty ->
      Psig_include (module_type modty)

  | Psig_class class_description_list ->
      Psig_class (List.map class_description class_description_list )

  | Psig_class_type class_type_declaration_list ->
      Psig_class_type (List.map class_type_declaration
			 class_type_declaration_list)

and modtype_declaration modty_decl = match modty_decl with
  | Pmodtype_abstract -> Pmodtype_abstract
  | Pmodtype_manifest modty -> Pmodtype_manifest (module_type modty)

and with_constraint constr = match constr with
  | Pwith_type type_decl -> Pwith_type (type_declaration type_decl)
  | Pwith_module longid -> Pwith_module (lazy_longident longid)
  | Pwith_typesubst type_decl -> Pwith_typesubst (type_declaration type_decl)
  | Pwith_modsubst longid -> Pwith_modsubst (lazy_longident longid)

(* value expressions for the module language *)

and structure s = List.flatten (List.map structure_item s)

and structure_item stritem =
  List.map (fun desc -> {
	      pstr_desc = desc;
	      pstr_loc = stritem.pstr_loc;
	    }) (structure_item_desc stritem.pstr_desc)

and structure_item_desc s = match s with
  | Pstr_eval expr ->
      [ Pstr_eval (expression expr) ]

  | Pstr_value (rec_flag, pat_exp_list) ->
      [ Pstr_value (rec_flag, 
		    (List.map (fun (pat, exp) ->
				 (lazy_pattern pat, delay_expr exp))
		       pat_exp_list)) ]

  | Pstr_primitive (str, val_desc) ->
      let prim =
	Pstr_primitive (str, { val_desc with pval_type =
			    nonlazy_core_type val_desc.pval_type })
      in
      let pat = { ppat_desc = Ppat_var str ; ppat_loc = Location.none } in
      let value =
	Pstr_value (Nonrecursive, [(pat, import_value str val_desc.pval_type)])
      in
	[ prim ; value ]
      
  | Pstr_type (str_ty_decl_list) ->
      [ Pstr_type (List.map (fun(str,ty_decl) ->
			       (str, type_declaration ty_decl))
		     str_ty_decl_list) ]

  | Pstr_exception (str, excp_decl) ->
      [ Pstr_exception (str, exception_declaration excp_decl) ]

  | Pstr_exn_rebind (str, longid) ->
      [ Pstr_exn_rebind (str, longident longid) ]

  | Pstr_module (str, mod_exp) ->
      [ Pstr_module (lazy_id str, module_expr mod_exp) ]

  | Pstr_recmodule (str_modty_modex_list) ->
      [ Pstr_recmodule (List.map (fun(str, modty, modex) ->
				    (lazy_id str, module_type modty,
				     module_expr modex))
			  str_modty_modex_list) ]

  | Pstr_modtype (str, modty) ->
      [ Pstr_modtype (lazy_id str, module_type modty) ]

  | Pstr_open longid ->
      [ Pstr_open (lazy_longident longid) ]

  | Pstr_class (classdecl_list) ->
      [ Pstr_class (List.map class_declaration classdecl_list) ]

  | Pstr_class_type (classtydecl_list) ->
      [ Pstr_class_type (List.map class_type_declaration classtydecl_list) ]

  | Pstr_include (modexp) ->
      [ Pstr_include (module_expr modexp) ]

and import_value v t =
  let exp exp_desc = { pexp_desc = exp_desc ; pexp_loc = Location.none } in
  let pat pat_desc = { ppat_desc = pat_desc ; ppat_loc = Location.none } in
  let frc = exp (Pexp_ident (Ldot (Lident "Lazy", "force"))) in
  let gen_vars nb_var =
    let rec f i acc =
      if i = 0 then acc else f (pred i) (("x" ^ string_of_int i) :: acc)
    in
      f nb_var []
  in
  let rec f k e t =
    match t.ptyp_desc with
      | Ptyp_alias (ct, _) | Ptyp_poly (_, ct)
      | Ptyp_constr (Ldot (Lident "*predef*", "option"), [ ct ]) -> f k e ct

      | Ptyp_any | Ptyp_var _ | Ptyp_constr (_, _) | Ptyp_object _ -> e

      | Ptyp_class (_, _, _) -> assert false
      | Ptyp_variant (_, _, _) -> assert false
      | Ptyp_package _ -> assert false

      | Ptyp_arrow (lab, ct1, ct2) ->
	  let k' = succ k in
	  let var = "camlinternal_var_" ^ string_of_int k in
	  let arg = g_force k' (exp (Pexp_ident (Lident var))) ct1 in
	  let call = exp (Pexp_apply (e, [ (lab, arg) ])) in
	  let body = f k' call ct2 in
	  let pt = pat (Ppat_var var) in
	    exp (Pexp_function (lab, None, [ (pt, body) ]))

      | Ptyp_tuple ct_list ->
	  let vars = gen_vars (List.length ct_list) in
	  let pats = List.map (fun v -> pat (Ppat_var v)) vars in
	  let pt = pat (Ppat_tuple pats) in
	  let exps = List.map (fun v -> exp (Pexp_ident (Lident v))) vars in
	  let tpl = exp (Pexp_tuple (List.map2 (lazy_f k) exps ct_list)) in
	    exp (Pexp_let (Nonrecursive, [ (pt, e) ], tpl))

  and lazy_f k e t = exp (Pexp_lazy (f k e t))

  and g k e t =
    match t.ptyp_desc with
      | Ptyp_alias (ct, _) | Ptyp_poly (_, ct)
      | Ptyp_constr (Ldot (Lident "*predef*", "option"), [ ct ]) -> g k e ct

      | Ptyp_any | Ptyp_var _ | Ptyp_constr (_, _) | Ptyp_object _ -> e

      | Ptyp_class (_, _, _) -> assert false
      | Ptyp_variant (_, _, _) -> assert false
      | Ptyp_package _ -> assert false

      | Ptyp_arrow (lab, ct1, ct2) ->
	  let k' = succ k in
	  let var =  "camlinternal_var_" ^ string_of_int k in
	  let expr = lazy_f k' (exp (Pexp_ident (Lident var))) ct1 in
	  let body = g k' (exp (Pexp_apply (e, [ (lab, expr) ]))) ct2 in
	  let pt = pat (Ppat_var var) in
	    exp (Pexp_function (lab, None, [ (pt, body) ]))

      | Ptyp_tuple ct_list ->
	  let vars = gen_vars (List.length ct_list) in
	  let pats = List.map (fun v -> pat (Ppat_var v)) vars in
	  let pt = pat (Ppat_tuple pats) in
	  let exps = List.map (fun v -> exp (Pexp_ident (Lident v))) vars in
	  let tpl = exp (Pexp_tuple (List.map2 (g k) exps ct_list)) in
	    exp (Pexp_let (Nonrecursive, [ (pt, e) ], tpl))

  and g_force k e t = g k (exp (Pexp_apply (frc, [ ("", e) ]))) t

  in
    lazy_f 1 (exp (Pexp_ident (Lident v))) t

let interface = signature;;

let implementation = structure;;
